home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / builtins.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  5.2 KB  |  166 lines  |  [TEXT/MPS ]
  1. (* builtins.ml : the pre-defined global identifiers *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "globals";;
  6. #open "hashtbl";;
  7. #open "modules";;
  8.  
  9. let builtin n d = {qualid={qual="builtin"; id=n}; info=d}
  10. ;;
  11.  
  12. (* Some types that must be known to the type checker *)
  13.  
  14. let constr_type_unit =
  15.   builtin "unit" {ty_stamp=2; ty_dang=false; ty_abbr=Tnotabbrev}
  16. and constr_type_exn =
  17.   builtin "exn" {ty_stamp=3; ty_dang=false; ty_abbr=Tnotabbrev}
  18. and constr_type_bool =
  19.   builtin "bool" {ty_stamp=4; ty_dang=false; ty_abbr=Tnotabbrev}
  20. and constr_type_int =
  21.   builtin "int" {ty_stamp=5; ty_dang=false; ty_abbr=Tnotabbrev}
  22. and constr_type_float =
  23.   builtin "float" {ty_stamp=6; ty_dang=false; ty_abbr=Tnotabbrev}
  24. and constr_type_string =
  25.   builtin "string" {ty_stamp=7; ty_dang=false; ty_abbr=Tnotabbrev}
  26. and constr_type_char =
  27.   builtin "char" {ty_stamp=8; ty_dang=false; ty_abbr=Tnotabbrev}
  28. and constr_type_list =
  29.   builtin "list" {ty_stamp=9; ty_dang=false; ty_abbr=Tnotabbrev}
  30. and constr_type_vect =
  31.   builtin "vect" {ty_stamp=10; ty_dang=true; ty_abbr=Tnotabbrev}
  32. and constr_type_stream =
  33.   {qualid = {qual="stream"; id="stream"};
  34.    info   = {ty_stamp=1; ty_dang=false; ty_abbr=Tnotabbrev}}
  35.     (* This assumes that "stream" is the first type defined in
  36.        the module "stream". *)
  37. ;;
  38.  
  39. let type_arrow (t1,t2) =
  40.   {typ_desc=Tarrow(t1, t2); typ_level=notgeneric}
  41. and type_product tlist =
  42.   {typ_desc=Tproduct(tlist); typ_level=notgeneric}
  43. and type_unit =
  44.   {typ_desc=Tconstr(constr_type_unit, []); typ_level=notgeneric}
  45. and type_exn =
  46.   {typ_desc=Tconstr(constr_type_exn, []); typ_level=notgeneric}
  47. and type_bool =
  48.   {typ_desc=Tconstr(constr_type_bool, []); typ_level=notgeneric}
  49. and type_int =
  50.   {typ_desc=Tconstr(constr_type_int, []); typ_level=notgeneric}
  51. and type_float =
  52.   {typ_desc=Tconstr(constr_type_float, []); typ_level=notgeneric}
  53. and type_string =
  54.   {typ_desc=Tconstr(constr_type_string, []); typ_level=notgeneric}
  55. and type_char =
  56.   {typ_desc=Tconstr(constr_type_char, []); typ_level=notgeneric}
  57. and type_vect t =
  58.   {typ_desc=Tconstr(constr_type_vect, [t]); typ_level=notgeneric}
  59. and type_stream t =
  60.   {typ_desc=Tconstr(constr_type_stream, [t]); typ_level=notgeneric}
  61. ;;
  62.  
  63. (* Some constructors that must be known to the parser *)
  64.  
  65. let constr_void =
  66.   builtin "()"
  67.     { cs_res = {typ_desc=Tconstr(constr_type_unit,[]); typ_level=notgeneric};
  68.       cs_arg = type_unit;
  69.       cs_tag = ConstrRegular(0,1);
  70.       cs_mut = Notmutable;
  71.       cs_kind= Constr_constant }
  72. ;;
  73.  
  74. let constr_nil =
  75.   let arg = {typ_desc=Tvar(Tnolink); typ_level=generic} in
  76.   builtin "[]"
  77.     { cs_res = {typ_desc=Tconstr(constr_type_list, [arg]); typ_level=generic};
  78.       cs_arg = type_unit;
  79.       cs_tag = ConstrRegular(0,2);
  80.       cs_mut = Notmutable;
  81.       cs_kind= Constr_constant }
  82.  
  83. and constr_cons =
  84.   let arg1 = {typ_desc=Tvar(Tnolink); typ_level=generic} in
  85.   let arg2 = {typ_desc=Tconstr(constr_type_list, [arg1]); typ_level=generic} in
  86.   builtin "::"
  87.     { cs_res = arg2;
  88.       cs_arg = {typ_desc=Tproduct[arg1; arg2]; typ_level=generic};
  89.       cs_tag = ConstrRegular(1,2);
  90.       cs_mut = Notmutable;
  91.       cs_kind= Constr_superfluous 2}
  92. ;;
  93.  
  94. let constr_false =
  95.   builtin "false"
  96.     { cs_res = {typ_desc=Tconstr(constr_type_bool,[]); typ_level=notgeneric};
  97.       cs_arg = type_unit;
  98.       cs_tag = ConstrRegular(0,2);
  99.       cs_mut = Notmutable;
  100.       cs_kind= Constr_constant }
  101.  
  102. and constr_true =
  103.   builtin "true"
  104.     { cs_res = {typ_desc=Tconstr(constr_type_bool,[]); typ_level=notgeneric};
  105.       cs_arg = type_unit;
  106.       cs_tag = ConstrRegular(1,2);
  107.       cs_mut = Notmutable;
  108.       cs_kind= Constr_constant }
  109. ;;
  110.  
  111. (* Some exceptions that must be known to the compiler *)
  112.  
  113. let match_failure_tag =
  114.   ConstrExtensible ({qual="builtin"; id="Match_failure"}, 1)
  115. ;;
  116.  
  117. let constr_match_failure =
  118.   builtin "Match_failure"
  119.     { cs_res = {typ_desc=Tconstr(constr_type_exn,[]); typ_level=notgeneric};
  120.       cs_arg = type_product [type_string; type_int; type_int];
  121.       cs_tag = match_failure_tag;
  122.       cs_mut = Notmutable;
  123.       cs_kind = Constr_superfluous 3 }
  124. ;;
  125.  
  126. (* Construction of the "builtin" module *)
  127.  
  128. let module_builtin = new_module "builtin";;
  129.  
  130. do_list
  131.   (fun (name,desc) ->
  132.       hashtbl__add module_builtin.mod_types name (builtin name desc))
  133.   ["unit",
  134.    {ty_constr=constr_type_unit; ty_arity=0; ty_desc=Variant_type[constr_void]};
  135.    "exn",
  136.     {ty_constr=constr_type_exn; ty_arity=0; ty_desc=Variant_type []};
  137.    "bool",
  138.     {ty_constr=constr_type_bool; ty_arity=0;
  139.      ty_desc=Variant_type [constr_false; constr_true]};
  140.    "int",
  141.     {ty_constr=constr_type_int; ty_arity=0; ty_desc=Abstract_type};
  142.    "float",
  143.     {ty_constr=constr_type_float; ty_arity=0; ty_desc=Abstract_type};
  144.    "string",
  145.     {ty_constr=constr_type_string; ty_arity=0; ty_desc=Abstract_type};
  146.    "char",
  147.     {ty_constr=constr_type_char; ty_arity=0; ty_desc=Abstract_type};
  148.    "list",
  149.     {ty_constr=constr_type_list; ty_arity=1;
  150.      ty_desc=Variant_type [constr_nil; constr_cons]};
  151.    "vect",
  152.     {ty_constr=constr_type_vect; ty_arity=1; ty_desc=Abstract_type}
  153.    ]
  154. ;;
  155. (* The type "stream" is defined in the "stream" module *)
  156.  
  157. do_list
  158.   (fun desc -> hashtbl__add module_builtin.mod_constrs desc.qualid.id desc)
  159.   [constr_void; constr_nil; constr_cons; constr_true; constr_false;
  160.    constr_match_failure ]
  161. ;;
  162.  
  163. hashtbl__add module_table "builtin" module_builtin
  164. ;;
  165.  
  166.